home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist01.zoo / lsp / repair.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1990-11-09  |  15.1 KB  |  458 lines
  1. ; New Structure Editor  by Tom Almy
  2.  
  3. ; (repair <symbol>)  or (repairf <symbol>) to repair only the function
  4. ; binding, with the capability of changing the argument list and type
  5. ; (MACRO or LAMBDA).
  6.  
  7. ; Execute (repairs symbol) to edit any symbol binding
  8.  
  9. ; Editor alters the "selection" by copying so that aborting  all changes
  10. ;  is generally posible.
  11. ; Exception: when editing a closure, if the closure is BACKed out of, the
  12. ;   change is permanent.
  13. ; For all commands taking a numeric argument, the first element of the
  14. ; selection is the 0th (as in NTH function).
  15.  
  16. ; Any array elements become lists when they are selected, and
  17. ; return to arrays upon RETURN or BACK commands.
  18.  
  19. ; Do not create new closures, because the environment will be incorrect.
  20.  
  21. ; Closures become LAMBDA or MACRO expressions when selected.  Only
  22. ; the closure body may be changed; the argument list cannot be successfully
  23. ; modified, nor can the environment.
  24.  
  25. ; For class objects, only the methods and selectors can be modified.  For
  26. ; instance objects, instance variables can be examined (if the object under-
  27. ; stands the message :<ivar> for the particular ivar), and changed 
  28. ; if :SET-IVAR is defined for that class (as it is if CLASSES.LSP is used)
  29.  
  30. ; COMMANDS:
  31. ;    CAR -- select the CAR of the current selection.
  32. ;    CDR -- select the CDR of the current selection.
  33. ;    n -- where n is small non-negative integer, changes selection
  34. ;            to (NTH n list)
  35. ;    RETURN -- exit, saving all changes
  36. ;    ABORT -- exit, without changes
  37. ;    BACK -- go back one level (as before CAR CDR or N commands)
  38. ;       B n -- go back n levels.
  39. ;    L -- display selection using pprint; if selection is symbol, give
  40. ;         short description
  41. ;    MAP -- pprints each element of selection, if selection is symbol
  42. ;              then give complete description of properties.
  43. ;       PLEN n -- change maximum print length (default 10)
  44. ;       PLEV n -- change maximum print depth (default 3)    
  45. ;    EVAL x -- evaluates x and prints result
  46. ;        The symbol @ is bound to the selection
  47. ;    REPLACE x -- replaces the selection with evaluated x.
  48. ;        The symbol @ is bound to the selection
  49. ; additional commands if selection is a symbol:
  50. ;    VALUE -- edit value binding
  51. ;    FUNCTION -- edit function binding (if a closure)
  52. ;    PROP x -- edit property x
  53. ; additional commands if selection is a list:
  54. ;    SUBST x y -- all occurances of (quoted) y are replaced with 
  55. ;        (quoted) x.  EQUAL is used for the comparison.
  56. ;    RAISE n -- removes parenthesis surrounding nth element of selection
  57. ;    LOWER n m -- inserts parenthesis starting with the nth element,
  58. ;        for m elements.
  59. ;    ARRAY n m -- as in LOWER, but makes elements into an array
  60. ;    I n x -- inserts (quoted) x before nth element in selection.
  61. ;    R n x -- replaces nth element in selection with (quoted) x.
  62. ;    D n -- deletes nth element in selection.
  63.  
  64.  
  65. ; Global variable used by repair functions
  66. (setf *rep-exit* 0)   ; "returning" flag
  67. (setf *rep-name* nil) ; name of what we are editing
  68.  
  69. (defvar *rep-plev* 3)    ; initial print level used
  70. (defvar *rep-plen* 10)    ; initial print length used
  71.                        
  72.                          
  73. ; repair a symbol -- the generic entry point
  74.  
  75. (defmacro repair (a)
  76.     (unless (symbolp a) (error (format nil "~s is not a symbol" a)))
  77.     (progv
  78.      '(*breakenable* *rep-exit* *rep-name* *print-level* *print-length*)
  79.      (list nil 0 (cons "symbol" a) *rep-plev* *rep-plen*)
  80.      (catch 'abort (rep-rep a)))
  81.      `',a)
  82.  
  83. ; repair a function, with editable arguments
  84.  
  85. (defmacro repairf (a)
  86.     (progv
  87.      '(*breakenable* *rep-exit* *rep-name* *print-level* *print-length*)
  88.      (list nil 0 (cons "function" a) *rep-plev* *rep-plen*)
  89.      (catch 'abort
  90.         (if (fboundp a)
  91.         (let ((x (rep-rep(get-lambda-expression(symbol-function a)))))
  92.              (cond ((eq (first x) 'lambda)
  93.                 `(defun ,a ,@(rest x)))
  94.                ((eq (first x) 'macro)
  95.                 `(defmacro ,a ,@(rest x)))
  96.                (t (error "not a closure!"))))
  97.         (error "can't repair")))))
  98.  
  99.  
  100. ; rep-propp returns T if p is a property of a
  101.  
  102. (defun rep-propp (a p)
  103.     (do     ((plist (symbol-plist a) (cddr plist)))
  104.         ((or (null plist) (eq (car plist) p))
  105.          (not (null plist)))))
  106.  
  107. ; terminate input line
  108.  
  109. (defun rep-teread (error) 
  110.     (if (not (eq (peek-char) #\Newline))
  111.         (read-line))
  112.     (if error
  113.         (princ "Try again:")
  114.         (format t "~a ~a>" (car *rep-name*) (cdr *rep-name*))))
  115.  
  116. (defmacro rep-protread () ;;Protected read -- we handle errors
  117.     '(do ((val (errset (read)) 
  118.           (progn (rep-teread t) (errset (read)))))
  119.         ((consp val) (car val))))
  120.  
  121. (defmacro rep-proteval () ;;protected eval -- we handle errors
  122.               ;; we also use evalhook so environment is global
  123.               ;;  plus a local @, which cannot be changed!
  124.     '(do* ((env (cons (list (list (cons '@ list))) nil))
  125.            (val (errset (evalhook (read) nil nil env))
  126.             (progn (rep-teread t) 
  127.                (errset (evalhook (read) nil nil env)))))
  128.           ((consp val) (car val))))
  129.  
  130.  
  131. ; Part of modified classes.lsp. Repeated here in case classes.lsp not used
  132.  
  133. (defun classp (name)
  134.        (when (objectp name)
  135.          (eq (send name :class) class)))
  136.  
  137. ; New methods so that we can "repair" methods.
  138. ; selectors :get-messages, :get-ivars, and :get-super changed to 
  139. ; :messages, :ivars, and :superclass to be compatible with new classes.lsp.
  140.  
  141. (send Class :answer :messages '() '(messages))
  142.  
  143. (send Class :answer :set-messages '(value) '((setf messages value)))
  144.  
  145. ; new methods so that we can examine/change instance variables
  146.  
  147. (send Class :answer :ivars '() '(ivars))
  148.  
  149. (send Class :answer :superclass '() '(superclass))
  150.  
  151. (defun rep-ivar-list (obj &aux (class (send obj :class)))
  152.     (do ((ivars (send class :ivars)
  153.             (append (send super :ivars) ivars))
  154.      (super (send class :superclass) (send super :superclass)))
  155.     ((eq super object) ivars)
  156.      ))
  157.  
  158. (defun rep-ivars (list object)
  159.     (mapcar #'(lambda (x)
  160.             (let ((y (errset (apply #'send
  161.                         (list object
  162.                           (intern (strcat ":"
  163.                                   (string x)))))
  164.                  nil)))
  165.           (if (consp y) (list x (car y)) x)))
  166.         list))
  167.  
  168. (defun rep-set-ivars (alist object)
  169.     (mapc #'(lambda (x)
  170.           (if (consp x)
  171.           (let ((y (errset (apply #'send
  172.                       (list object
  173.                             :set-ivar
  174.                         (car x)
  175.                             (cadr x)))
  176.                    nil)))
  177.             (unless (consp y)
  178.                 (princ (list (car x) " not set."))
  179.                 (terpri)))
  180.           (progn (princ (list x "not set.")) (terpri))))
  181.       alist))
  182.  
  183. ; help function
  184. (defun rep-help (list)
  185.        (terpri)
  186.        (princ "Available commands:\n\n")
  187.        (princ "?\t\tprint list of commands\n")
  188.        (princ "RETURN\t\texit, saving all changes\n")
  189.        (princ "ABORT\t\texit, without changes\n")
  190.        (princ "BACK\t\tgo back one level (as before CAR CDR or N commands)\n")
  191.        (princ "B n\t\tgo back n levels\n")
  192.        (cond ((symbolp list)
  193.           (princ "L\t\tshort description of selected symbol\n")
  194.           (princ "MAP\t\tcomplete description of selected symbols properties\n"))
  195.          ((consp list)
  196.           (princ "L\t\tshow selection (using pprint)\n")
  197.           (princ "MAP\t\tpprints each element of selection\n"))
  198.          (t 
  199.           (princ "L\t\tshow selection (using pprint)\n")
  200.           (princ "MAP\t\tshow selection (using pprint)\n")))
  201.        (format
  202.     t 
  203.     "PLEV n\t\tsets number of levels of printing (now ~s) NIL=infinite\n"
  204.     *print-level*)
  205.        (format
  206.     t
  207.     "PLEN n\t\tsets length of list printing (now ~s) NIL=infinite\n"
  208.     *print-length*)
  209.        (princ "EVAL x\t\tevaluates x and prints result\n")
  210.        (princ "\t\tNote the symbol @ is bound to the selection\n")
  211.        (princ "REPLACE x\treplaces the selection with evaluated x\n")
  212.        (princ "\t\tNote the symbol @ is bound to the selection\n")
  213.        (when (symbolp list)
  214.          (princ "FUNCTION\tedit the function binding\n")
  215.          (princ "VALUE\t\tedit the value binding\n")
  216.          (princ "PROP pname\tedit property pname\n")
  217.          (return-from rep-help nil))
  218.        (unless (consp list) (return-from rep-help nil))
  219.        (princ "CAR\t\tSelect the CAR of the selection\n")
  220.        (princ "CDR\t\tSelect the CDR of the selection\n")
  221.        (princ "n\t\tSelect the nth element in the selection (0 based)\n")
  222.        (princ "SUBST x y\tall EQUAL occurances of y are replaced with x\n")
  223.        (princ "RAISE n\t\tremoves parenthesis surrounding nth element of the selection\n")
  224.        (princ "LOWER n m\tinserts parenthesis starting with the nth element,\n")
  225.        (princ "\t\tfor m elements of the selection\n")
  226.        (princ "ARRAY n m\tas in LOWER, but makes elements into an array\n")
  227.        (princ "I n x\t\tinserts (quoted) x before nth element in selection\n")
  228.        (princ "R n x\t\treplaces nth element in selection with (quoted) x\n")
  229.        (princ "D n\t\tdeletes nth element in selection\n"))
  230.  
  231.  
  232. ; rep-rep repairs its argument.  It looks at the argument type to decide
  233. ;  how to do the repair.
  234. ;  ARRAY  -- repair as list
  235. ;  OBJECT -- if class, repair MESSAGE ivar, else repair list of ivars
  236. ;  CLOSURE -- allows repairing of closure body by destructive modification
  237. ;             upon return
  238. ;  OTHER  -- repair as is.
  239.  
  240. (defun rep-rep (list) 
  241.     (cond ((arrayp list) 
  242.            (princ "Editing array") 
  243.            (terpri)
  244.            (coerce (rep-rep2 (coerce list 'cons)) 'array))
  245.           ((classp list)
  246.            (princ "Editing Methods")
  247.            (terpri)
  248.            (send list :set-messages 
  249.                     (rep-rep2 (send list :messages)))
  250.            list) ; return the object
  251.           ((objectp list)
  252.            (princ "Editing Instance Vars")
  253.            (terpri)
  254.            (rep-set-ivars (rep-rep2 
  255.                            (rep-ivars 
  256.                     (rep-ivar-list list) list)) list)
  257.            list) ; return the object
  258.           ((eq (type-of list) 'closure)
  259.            (princ "Editing closure")
  260.            (terpri)
  261.            (let*  ((orig (get-lambda-expression list))
  262.                    (new (rep-rep2 orig)))
  263.               (when (not (equal (second orig) (second new)))
  264.                       (princ "Argument list unchanged")
  265.                 (terpri))
  266.               (rplaca (cddr orig) (caddr new))
  267.               (rplacd (cddr orig) (cdddr new))
  268.               list)) ; return closure
  269.           (t (rep-rep2 list))))
  270.  
  271.  
  272. ; printing routines
  273.  
  274. ; print a property list
  275. (defun rep-print-prop (plist verbosity)
  276.     (when plist
  277.           (princ "Property: ")
  278.           (princ (car plist))
  279.           (when verbosity
  280.                 (princ "  ")
  281.             (prin1 (cadr plist)))
  282.           (terpri)
  283.           (rep-print-prop (cddr plist) verbosity)))
  284.  
  285. ; print a symbols function binding, value, and property list
  286. (defun rep-print-symbol (symbol verbosity)
  287.     (print symbol)
  288.     (when (fboundp symbol)
  289.           (if verbosity 
  290.           (progn (princ "Function:")
  291.                (terpri)
  292.              (if (eq (type-of (symbol-function symbol)) 'closure)
  293.                  (pprint (get-lambda-expression
  294.                       (symbol-function symbol)))
  295.                  (print (symbol-function symbol))))
  296.           (progn (princ "Function binding") (terpri))))
  297.     (when (boundp symbol)
  298.           (if verbosity
  299.               (progn (princ "Value:")
  300.                (terpri)
  301.              (pprint (symbol-value symbol)))
  302.           (progn (princ "Value binding") (terpri))))
  303.     (when (symbol-plist symbol)
  304.           (rep-print-prop (symbol-plist symbol) verbosity))
  305. )
  306.  
  307. ; print a list, using mapcar
  308. (defun rep-print-map (list &aux (x 0))
  309.        (mapc #'(lambda (y)
  310.                (format t "(~s) " (prog1 x (setf x (1+ x)) ))
  311.                (pprint y))
  312.          list))
  313.  
  314. ; main list repair interface
  315. (defun rep-rep2 (list) 
  316.     (prog (command n)
  317.     y (rep-teread nil)
  318.       (setq command (rep-protread))
  319.       (cond    ((eq command '?) (rep-help list))
  320.         ((eq command 'return) (setq *rep-exit* -1))
  321.         ((eq command 'abort) (throw 'abort))
  322.         ((eq command 'back) (return list))
  323.         ((and (eq command 'b)
  324.               (integerp (setq n (rep-protread)))
  325.               (> n 0))
  326.          (setq *rep-exit* n))
  327.         ((eq command 'l)
  328.          (if (symbolp list) (rep-print-symbol list nil) (print list)))
  329.         ((eq command 'map)
  330.          (cond ((symbolp list) (rep-print-symbol list t))
  331.                ((consp list) (rep-print-map list))
  332.                (t (pprint list))))
  333.         ((eq command 'eval) (print (rep-proteval)))
  334.         ((and (eq command 'plev)
  335.               (or (and (integerp (setq n (rep-protread)))
  336.                    (>= n 1))
  337.               (null n)))
  338.          (format t "Was ~s\n" *print-level*)
  339.          (setq *print-level* n))
  340.         ((and (eq command 'plen)
  341.               (or (and (integerp (setq n (rep-protread)))
  342.                    (>= n 1))
  343.               (null n)))
  344.          (format t "Was ~s\n" *print-length*)
  345.          (setq *print-length* n))
  346.         ((eq command 'replace) 
  347.          (setq n (rep-proteval))
  348.          (if (eq (type-of n) (type-of list))
  349.              (setq list n)
  350.              (return (rep-rep n))))
  351. ; symbol only commands
  352.         ((and (symbolp list)
  353.               (eq command 'function) 
  354.               (fboundp list)
  355.               (eq (type-of (symbol-function list)) 'closure))
  356.          (progv '(*rep-name*) 
  357.             (list (cons "function" list))
  358.             (setf (symbol-function list) 
  359.                   (rep-rep (symbol-function list)))))
  360.         ((and (symbolp list)
  361.               (eq command 'value)
  362.               (boundp list))
  363.          (progv '(*rep-name*)
  364.             (list (cons "value" list))
  365.             (setf (symbol-value list)
  366.                   (rep-rep (symbol-value list)))))
  367.         ((and (symbolp list)
  368.               (eq command 'prop)
  369.               (symbolp (setq n (rep-protread)))
  370.               (rep-propp list n))
  371.          (progv '(*rep-name*)
  372.             (list (cons n list))
  373.             (setf (get list n) (rep-rep (get list n)))))
  374. ; cons only commands
  375.         ((and (consp list)
  376.               (eq command 'car))
  377.          (setq list (cons (rep-rep (car list)) (cdr list))))
  378.         ((and (consp list)
  379.               (eq command 'cdr))
  380.          (setq list (cons (car list) (rep-rep (cdr list)))))
  381.         ((and (consp list)
  382.               (integerp command)
  383.               (> command -1) 
  384.               (< command (length list)))
  385.          (setq list (append
  386.                  (subseq list 0 command)
  387.                  (list (rep-rep (nth command list)))
  388.                  (nthcdr (1+ command) list))))
  389.         ((and (consp list)
  390.               (eq command 'raise) 
  391.               (integerp (setq n (rep-protread)))
  392.               (> n -1) 
  393.               (< n (length list))
  394.               (or (consp (nth n list)) (arrayp (nth n list))))
  395.          (setq list (append
  396.                  (subseq list 0 n)
  397.                  (let ((x (nth  n list)))
  398.                   (if (arrayp x)
  399.                       (coerce x 'cons)
  400.                       x))
  401.                  (nthcdr (1+ n) list))))
  402.         ((and (consp list)
  403.               (eq command 'lower)
  404.               (integerp (setq n (rep-protread)))
  405.               (> n -1)
  406.               (integerp (setq n2 (rep-protread)))
  407.               (> n2 0)
  408.               (>= (length list) (+ n n2)))
  409.          (setq list (append
  410.                  (subseq list 0 n)
  411.                  (list (subseq list n (+ n n2)))
  412.                  (nthcdr (+ n n2) list))))
  413.         ((and (consp list)
  414.               (eq command 'array)
  415.               (integerp (setq n (rep-protread)))
  416.               (> n -1)
  417.               (integerp (setq n2 (rep-protread)))
  418.               (> n2 0)
  419.               (>= (length list) (+ n n2)))
  420.          (setq list (append
  421.                  (subseq list 0 n)
  422.                  (list (coerce (subseq list n (+ n n2)) 'array))
  423.                  (nthcdr (+ n n2) list))))
  424.         ((and (consp list)
  425.               (eq command 'i) 
  426.               (integerp (setq n (rep-protread)))
  427.               (> n -1))
  428.          (setq list (append
  429.                  (subseq list 0 n)
  430.                  (list (rep-protread))
  431.                  (nthcdr n list))))
  432.         ((and (consp list)
  433.               (eq command 'r) 
  434.               (integerp (setq n (rep-protread)))
  435.               (> n -1))
  436.          (setq list (append
  437.                  (subseq list 0 n)
  438.                  (list (rep-protread))
  439.                  (nthcdr (1+ n) list))))
  440.         ((and (consp list)
  441.               (eq command 'd) 
  442.               (integerp (setq n (rep-protread)))
  443.               (> n -1))
  444.          (setq list (append
  445.                  (subseq list 0 n)
  446.                  (nthcdr (1+ n) list))))
  447.         ((and (consp list)
  448.               (eq command 'subst))
  449.          (setq list (subst (rep-protread) 
  450.                    (rep-protread) 
  451.                    list
  452.                    :test #'equal)))
  453.         (t (princ "What??\n") (go y)))
  454.  
  455.       (when (zerop *rep-exit*) (go y))
  456.       (setq *rep-exit* (1- *rep-exit*))
  457.       (return list)))
  458.